home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / combin.arc / COMBIN.PAS < prev   
Pascal/Delphi Source File  |  1985-08-24  |  9KB  |  181 lines
  1. {$g512,P512,D-}
  2. {  This program will take a Turbo main line program and create a file that
  3.    contains all of the code for the program, main line plus include files.
  4.    The program uses I/O re-direction and requires TP3. A sample command line
  5.    would be like the following :
  6.  
  7.          combine  < main.pas > allone.pas
  8.  
  9.    To create a file called 'allone.pas' that contains all of the code
  10.    for main.pas plus all of the include files.
  11.  
  12.  
  13.    WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
  14.  
  15.       Path names are not supported in the include directives for this
  16.       program.
  17.  
  18. }
  19.  
  20. program combine(input,output);
  21.  
  22. type
  23.   FCB_Layout            =    record
  24.                                Drive             :    byte;
  25.                                FileName          :    Array[1..8] of char;
  26.                                FileExt           :    Array[1..3] of char;
  27.                                CurBlock          :    integer;
  28.                                RecSize           :    integer;
  29.                                FSizeLow          :    integer;
  30.                                FSizeHigh         :    integer;
  31.                                CreateDate        :    integer;
  32.                                CreateTime        :    integer;
  33.                                Flags             :    byte;
  34.                                DiskAddr1st       :    integer;
  35.                                DiskAddrLst       :    integer;
  36.                                LastAccess        :    Array [1..3] of byte;
  37.                                NextRecord        :    byte;
  38.                                RelRecLow         :    integer;
  39.                                RelRecHigh        :    integer;
  40.                              end;
  41.  
  42.   Registers             =    Record Case Integer Of
  43.                              1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
  44.                              2: (al,ah,bl,bh,cl,ch,dl,dh: Byte);
  45.                              End;
  46.   Alpha                 =    String[255];
  47.  
  48. var
  49.   MBuffer,
  50.   Buffer                :    Alpha;
  51.   i                     :    integer;
  52.   Ok                    :    boolean;
  53.   F                     :    Alpha;
  54.  
  55. {*********************************************************************}
  56.  
  57. {  Read the Include file and output it, every byte }
  58.  
  59. procedure ReadInclude(F:Alpha;var Ok:boolean);
  60. var
  61.   Ch                    :    char;
  62.   IFile                 :    Text;
  63.  
  64. begin
  65.   Assign(IFile,F);                     { Assign the include file             }
  66.   {$I-} Reset(IFile) {$I+};            { try to open the file                }
  67.   Ok:=(IOresult=0);                    { was there any problem               }
  68.   if Ok then                           { if not then lets go to work         }
  69.     begin                              { start the ball rolling              }
  70.       writeln('{*Include File     ',F,' ***** START *****}');
  71.       while not Eof(IFile) do          { loop through the entire file        }
  72.         begin                          { till we get to the end              }
  73.           read(IFile,Ch);              { read a character, ( could be better)}
  74.           write(Ch);                   { write a character, How boring       }
  75.         end;                           { Loop one, Branch two                }
  76.       writeln;                         { make sure your at the left margin   }
  77.       writeln('{*Include File End ',F,' ***** END *****}');
  78.       close(IFile);                    { close the file                      }
  79.     end;                               { end of 'file found code'            }
  80. end;
  81.  
  82. { ************************************************************************
  83.  
  84.    Take a string and scan it for a file name, using a pre-MSDOS 2 system
  85.    call.  Since there is not a call like this that supports paths the
  86.    file names will be minus the path names.
  87.  
  88. }
  89. function FileNameScan(S:Alpha):Alpha;
  90. var
  91.   T                     :    FCB_Layout;
  92.   i                     :    integer;
  93.   Regs                  :    Registers;
  94.   k                     :    integer;
  95.  
  96. begin
  97.   S:=S+Chr(0);                         { MSDOS requires ASCIIZ strings       }
  98.   with Regs do                         { set up the registers for the call   }
  99.     begin                              { using the registers                 }
  100.       ah:=$29;                         { function 29 hex                     }
  101.       al:=0;                           {  see manual ( too complex for here) }
  102.       DS:=Seg(S);                      { pass segment address of string      }
  103.       SI:=Ofs(S)+1;                    { offset , skip length byte           }
  104.       ES:=Seg(T);                      { pas address (segment) of FCB        }
  105.       DI:=Ofs(T);                      { pass the offset                     }
  106.     end;                               { all set for call                    }
  107.   with T do                            { let ready the FCB for the call      }
  108.     begin                              { ok, lets do it .....                }
  109.       for i:=1 to 8 do                 { clear file name                     }
  110.         FileName[i]:=' ';              { to blanks                           }
  111.       for i:=1 to 3 do                 { clear file extention                }
  112.         FileExt[i]:=' ';               { to blanks                           }
  113.     end;                               { FCB ready                           }
  114.   MsDos(Regs);                         { call DOS                            }
  115.   with T do                            { ok, lets look at the FCB            }
  116.     begin                              { and pull out the info               }
  117.       k:=0;                            { string length is zero               }
  118.       for i:=1 to 8 do                 { loop through the file name          }
  119.         if not(FileName[i]=' ') then   { blank ???                           }
  120.           begin                        { no, good then lets grab the char    }
  121.             k:=k+1;                    { one more into the string            }
  122.             S[k]:=FileName[i];         { MOVE IT                             }
  123.           end;                         { continue .........                  }
  124.       k:=k+1;                          { count the period                    }
  125.       S[k]:='.';                       { and put it into the string          }
  126.       for i:=1 to 3 do                 { now move the extention              }
  127.         if not(FileExt[i]=' ') then    { blank ????                          }
  128.           begin                        { no, good let move it                }
  129.             k:=k+1;                    { count the sucker                    }
  130.             S[k]:=FileExt[i];          { move it ... march .. left .. right  }
  131.           end;                         { one more time ...                   }
  132.       S[0]:=Chr(k);                    { set string length                   }
  133.     end;
  134.   FileNameScan:=S;                     { return our stuff                    }
  135. end;
  136.  
  137. { function to convert lower case variable names to uppercase for comparison
  138.   since variable names are case insensative. }
  139.  
  140. function UpStr(s:alpha):alpha;
  141. var
  142.   i                     :    integer;
  143. begin
  144.   for i:=1 to length(s) do
  145.     s[i]:=UpCase(s[i]);
  146.   UpStr:=s;
  147. end;
  148.  
  149. { ---------------------------------------------------------------------
  150.  
  151.       Main line code, read a line from the file and check for an
  152.       include directive. If found the put the text from the include
  153.       file into the output file and then continue.  But do not
  154.       move the include file directive into the output file.
  155.  
  156. }
  157.  
  158. begin
  159.   while not Eof(input) do              { while there is more input do        }
  160.     begin                              { loop ..........                     }
  161.       Readln(Buffer);                  { read a line                         }
  162.       MBuffer:=UpStr(Buffer);          { convert to upper case               }
  163.       i:=Pos('$I',MBuffer);            { look for directive                  }
  164.       if (MBuffer[i+2]='+') or         { was it I+                           }
  165.          (MBuffer[i+2]='-') then i:=0; { was it I-, if so don't do anything  }
  166.       If not(i=0) then                 { ok, was it for real                 }
  167.         begin                          { yes, lets get the file name and run }
  168.           F:=FileNameScan(copy(MBuffer,i+2,Length(MBuffer)));
  169.           ReadInclude(F,Ok);           { try to process the include file     }
  170.           if not Ok then               { was it there ????                   }
  171.             begin                      { no ... sob ... sob                  }
  172.               writeln('{ Include File ',F,' NOT Found }');
  173.               writeln('Include file ',F,' , not found.');
  174.             end;                       { output the bad new, force compile error }
  175.         end                            { ok done for include directive       }
  176.       else                             { otherwise .........                 }
  177.         writeln(Buffer);               { output the line                     }
  178.     end;
  179. end.
  180.  
  181.